home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…stman Always Clicks Twice / ADC Developer CD (1993-01) (''The Postman Always Clicks Twice'')_iso / Dev.CD 199301.iso / Development Platforms / LISP Related / LISP Goodies / matt's utils 8sept / drag-gray-region-lisp.lisp < prev    next >
Encoding:
Text File  |  1992-08-17  |  8.9 KB  |  255 lines  |  [TEXT/CCL2]
  1. ;;;
  2. ;;; drag-gray-region-lisp.lisp
  3. ;;;
  4.  
  5. #|
  6. ================================================================
  7. Purpose ========================================================
  8. ================================================================
  9. Defines drag-gray-region-lisp .
  10.  
  11.  
  12. ================================================================
  13. Status =========================================================
  14. ================================================================
  15. Implemented.
  16.  
  17. Copyright © 1990-92 Matthew Cornell. All Rights Reserved. Send
  18. bugs, comments, questions, and fixes to cornell@cs.umass.edu.
  19.  
  20.  
  21. ================================================================
  22. Change history =================================================
  23. ================================================================
  24. 02-Aug-92 mc    Created.
  25. 04-Aug-92 mc    Changed drag-gray-region-lisp's args to take pt-global-start,
  26.          and to return the delta.
  27. 05-Aug-92 mc    Fixed: Bug: If one clicks and moves quickly the mouse away
  28.          from the click point, the gray region is offset from the mouse
  29.          point.
  30. 15-Aug-92 mc    Fixed drag-gray-region-lisp to clipt to port-wmgr's portRect.
  31. 17-Aug-92 mc    Changed drag-gray-region-lisp to use #_DragGrayRgn .
  32.  
  33. |#
  34.  
  35.  
  36. (in-package "CCL")
  37.  
  38. (export '(DRAG-GRAY-REGION-LISP))
  39.  
  40.  
  41. ;;;================================================================
  42. ;;;
  43. ;;;================================================================
  44.  
  45. ;;; Window-manager-port is from Apple's ift-macros.lisp:
  46.  
  47. (defmacro window-manager-port ()
  48.   '(%stack-block ((port 4))
  49.      (require-trap #_GetWMgrPort :ptr port)
  50.      (%get-ptr port)))
  51.  
  52.  
  53. (defgeneric drag-gray-region-lisp (macptr-region-global
  54.                                    function
  55.                                    pt-global-start
  56.                                    &key cursor axis-constraint)
  57.   (:documentation "A clean and simple lisp-level version of #_DragGrayRgn.
  58. Inverts macptr-region-global at the mouse position, destroying
  59. macptr-region-global in the process. macptr-region-global is drawn in
  60. the window manager's port so should be created relative to #@(0 0).
  61. Function is called each time the mouse moves; it takes one argument:
  62. pt-global-current, which is the current global mouse position. Cursor is
  63. a macptr of a cursor used during tracking, and defaults to
  64. *arrow-cursor*. axis-constraint is one of :no-constraint, :h-axis-only, or
  65. :v-axis-only. Returns a point that is the difference between the global
  66. point released at and pt-global-start."))
  67.  
  68.  
  69. (defmethod drag-gray-region-lisp ((macptr-region-global macptr)
  70.                                   (function function)
  71.                                   (pt-global-start integer)
  72.                                   &key (cursor *arrow-cursor*)
  73.                                   (axis-constraint :no-constraint))
  74.   (declare (optimize speed))
  75.   ;;
  76.   ;; A version that uses #_DragGrayRgn .
  77.   ;;
  78.   (let* ((port-wmgr (window-manager-port))
  79.          (macptr-portrect-wmgr (rref port-wmgr grafPort.portRect)))
  80.     ;; Setup the call to proc-call-fcn then call #_DragGrayRgn .
  81.     (setf *pt-global-last* pt-global-start
  82.           *function-dragging* function)
  83.     (with-cursor cursor
  84.       (with-port port-wmgr
  85.         (with-pen-saved
  86.           (with-clip-rect macptr-portrect-wmgr
  87.             ;; Make the call, which returns the resulting difference.
  88.             (#_DragGrayRgn macptr-region-global pt-global-start
  89.              macptr-portrect-wmgr macptr-portrect-wmgr
  90.              (ecase axis-constraint
  91.                (:no-constraint 0)
  92.                (:h-axis-only 1)
  93.                (:v-axis-only 2))
  94.              proc-call-fcn)))))))
  95.  
  96.  
  97. (defvar *pt-global-last* 0
  98.   "Used by proc-call-fcn to know when the mouse has moved.")
  99.  
  100.  
  101. (defvar *function-dragging*
  102.   "Used by proc-call-fcn to know what function to call.")
  103.  
  104.  
  105. (defmacro funcall-saving-port (function port point)
  106.   `(with-port ,port
  107.      (with-pen-saved (funcall ,function ,point))))
  108.  
  109.  
  110. (defpascal proc-call-fcn ()
  111.   (let* ((old-point *pt-global-last*)
  112.          (pt-global-new (view-mouse-position nil))
  113.          (moved? (/= old-point pt-global-new)))
  114.     (when moved? (setf *pt-global-last* pt-global-new)
  115.       (funcall-saving-port *function-dragging* (window-manager-port) pt-global-new))))
  116.  
  117.  
  118. ;;; Done.
  119.  
  120. (provide "DRAG-GRAY-REGION-LISP")
  121.  
  122.  
  123. #| ;;; Define some example code.
  124.  
  125.  
  126. ;;; Global-to-local and local-to-global from "quickdraw.lisp" :
  127.  
  128. (unless (fboundp 'global-to-local)
  129.   (defmethod global-to-local ((view simple-view) h &optional v)
  130.     (with-focused-view view
  131.       (rlet ((p :point))
  132.         (%put-long p (make-point h v))
  133.         (#_GlobalToLocal p)
  134.         (%get-long p)))))
  135.  
  136. (unless (fboundp 'local-to-global)
  137.   (defmethod local-to-global ((view simple-view) h &optional v)
  138.     (with-focused-view view
  139.       (rlet ((p :point))
  140.         (%put-long p (make-point h v))
  141.         (#_LocalToGlobal p)
  142.         (%get-long p)))))
  143.  
  144.  
  145. (defmethod view-invert-marker ((view null) (pt-global integer))
  146.   )
  147.  
  148. (defmethod view-invert-marker ((view simple-view) (pt-global integer))
  149.   ;; Invert a small box at pt-global, local to view.
  150.   (let* ((pt-top-left-global (subtract-points pt-global #@(3 3)))
  151.          (pt-bottom-right-global (add-points pt-top-left-global #@(6 6)))
  152.          (pt-top-left (global-to-local view pt-top-left-global))
  153.          (pt-bottom-right (global-to-local view pt-bottom-right-global)))
  154.     (rlet ((rect :rect :topLeft pt-top-left :bottomRight pt-bottom-right))
  155.       (with-focused-view view           ;with-port (window-manager-port)
  156.         (#_InvertRect rect))))
  157.   ;; Invert a gray frame just inside view. (Headache if it's thick!)
  158.   '(let* ((pt-top-left #@(0 0))
  159.          (pt-bottom-right (view-size view)))
  160.     (rlet ((rect :rect :topLeft pt-top-left :bottomRight pt-bottom-right))
  161.       (with-focused-view view
  162.         (with-pen-saved
  163.           (#_PenMode (position :PATXOR *pen-modes*))
  164.           (#_PenPat *gray-pattern*)
  165.           (#_PenSize 3 3)
  166.           (#_FrameRect rect))))))
  167.  
  168.  
  169. (defclass demo-view (button-dialog-item)
  170.   ())
  171.  
  172.  
  173. (defmethod view-click-event-handler ((view demo-view) where)
  174.   ;;
  175.   (let* ((str-dialog-item-text-old (dialog-item-text view))
  176.          (macptr-region-global (#_NewRgn))
  177.          (pt-top-left (local-to-global view 0))
  178.          (pt-bottom-right (local-to-global view (view-size view)))
  179.          (pt-global-last (local-to-global (view-container view) where))
  180.          (view-last (find-view-containing-point nil pt-global-last))
  181.          pt-difference)
  182.     (set-dialog-item-text view "Tracking…")
  183.     ;;
  184.     (rlet ((rect :rect :topLeft pt-top-left :bottomRight pt-bottom-right))
  185.       (#_RectRgn macptr-region-global rect)
  186.       ;; Invert initial:
  187.       (view-invert-marker (find-view-containing-point nil pt-global-last)
  188.                           pt-global-last)
  189.       (setf pt-difference
  190.             (drag-gray-region-lisp
  191.              macptr-region-global
  192.              #'(lambda (pt-global-current)
  193.                  (when (option-key-p)
  194.                    (set-dialog-item-text
  195.                     view (format nil "~A ~A" (point-string pt-global-current)
  196.                                  (type-of view-last))))
  197.                  ;; Invert old:
  198.                  (view-invert-marker view-last pt-global-last)
  199.                  (setf pt-global-last pt-global-current
  200.                        view-last (find-view-containing-point nil pt-global-current))
  201.                  ;; Invert new:
  202.                  (view-invert-marker view-last pt-global-last))
  203.              pt-global-last
  204.              :cursor *i-beam-cursor*
  205.              :axis-constraint (cond ((shift-key-p) :h-axis-only)
  206.                                     ((option-key-p) :v-axis-only)
  207.                                     (t :no-constraint))))
  208.       ;; Invert last then dispose.
  209.       (view-invert-marker view-last pt-global-last)
  210.       (#_DisposeRgn macptr-region-global))
  211.     ;;
  212.     (set-dialog-item-text view str-dialog-item-text-old)
  213.     (print (point-string pt-difference))))
  214.  
  215.  
  216. ;;; Test.
  217.  
  218. (defun test-drag ()
  219.   (let* ((window
  220.           (make-instance
  221.             'window :window-title "Test Drag"
  222.             :view-position #@(420 40)
  223.             :view-size #@(210 60)
  224.             :view-subviews
  225.             (list (make-instance 'demo-view
  226.                     :view-size #@(200 20)
  227.                     :view-font '("Geneva" 9)
  228.                     :dialog-item-text "Start Dragging (try Option key)")))))
  229.     window))
  230.  
  231.  
  232. ;;; Test with scrollers.
  233.  
  234. (require "SCROLLERS")
  235.  
  236. (defun test-drag-scroller ()
  237.   (let* ((window (make-instance
  238.                    'window :window-title "Test Drag"
  239.                    :view-position #@(420 40)
  240.                    :view-size #@(170 150)))
  241.          (scroller (make-instance 'scroller
  242.                      :view-container window
  243.                      :view-size #@(125 125)
  244.                      :track-thumb-p t))
  245.          (demo-view (make-instance 'demo-view
  246.                       :view-position #@(50 50)
  247.                       :view-size #@(200 20)
  248.                       :view-font '("Geneva" 9)
  249.                       :dialog-item-text "Start Dragging (try Option key)"
  250.                       :view-container scroller)))
  251.     (declare (ignore demo-view))
  252.     ;;
  253.     window))
  254.  
  255. |#